COMMENT ⊗   VALID 00002 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00002 00002	(declare (fasload util fas dsk (aid lsp)))
C00009 ENDMK
C⊗;
(declare (fasload util fas dsk (aid lsp)))
(declare (mapex t) (special over-ride-quote macex-finally current-file))

(cond ((boundp 'over-ride-quote))
      (t (setq over-ride-quote nil)))

(defun macex fexpr (file)
 (apply 'eread file)
 (uwrite)
 (let current-file ← (status uread) do
 (unselect-tty
  (select-disk-input
   (select-disk-output
    (read-until-eof with form do
	(cond ((atom form) (sprinter form))
	      ((memq (car form) '(macro macrodef require))
	       (unselect-disk-output
	       (eval form)))
	      ((or (eq (cadr form) 'macro)
		   (eq (caddr form) 'macro))
	       (unselect-disk-output
	       (eval form)))
;	      ((and (eq (car form) 'declare)
;		    (eq (car (cadr form)) 'require)))
	      ((and (not (getl 'defun '(trans macro)))
		    (eq (car form) 'defun))
	         (sprinter (cond ((and (caddr form)
				       (atom (caddr form))
				       (eq (caddr form) 'fexpr))
				  (nconc (list (car form)
					       (cadr form)
					       (caddr form)
					       (cadddr form))
					 (mapcar 'macro-expand (cddddr form))))   
				 (t (nconc 
				     (list 
					(car form)
					(cadr form) 
					(caddr form))
			    	  (mapcar 'macro-expand (cdddr form))))))) 
	      (t (sprinter (macro-expand form)))))   
 	(and (boundp 'macex-finally)
      	     (funcall macex-finally))))))
 (let f ← (list (car file) 'exp)
      do
      (cond ((probef (namelist f))
	     (deletef (namelist f))))
      (apply 'ufile (list (car file) 'exp)))
 file)

(defun macro-expand (form)
 (cond ((null form) nil)
       ((atom form) form)
       ((and (atom (car form))(get (car form) 'primitive)) 
	(cons (car form) (mapcar 'macro-expand (cdr form))))
       ((and (not over-ride-quote)
	     (eq (car form) 'quote)) form)
       ((memq (car form) '(lambda prog ; α-lambda α-prog
				  ))
	(nconc (list (car form) (cadr form))
	       (mapcar 'macro-expand (cddr form))))
       ((memq (car form) '(cond ;α-cond
			   ))
	(cons (car form)
	      (mapcar 
	       (function 
		(lambda (q)
			(mapcar 'macro-expand q)))
	       (cdr form))))
       ((get (car form) 'trans)
	((lambda (x)
	  (cond ((atom (car x))
          	 (rplacd x
	   	  (macro-mapall 'macro-expand
	    		  (cdr x))))
		(t (macro-expand x))))
	 (trans-replace form)))  
       ((eq (car form) 'do)
	(cons (car form)
	      (cons 
	       (mapcar 
		(function 
		 (lambda (x)
			 (cons (car x)
			       (mapcar 'macro-expand (cdr x)))))
		(cadr form))
	       (mapcar 'macro-expand (cddr form)))))
       ((get (car form) 'macro)
       	(macro-expand (macro-replace form)))
;      ((get (car form) 'α-macro)
;      	(macro-expand (α-macro-replace form)))
       (t (macro-mapall 'macro-expand form)))) 

(defun macro-mapall (f l)
 (cond ((null l) nil)
       ((atom l) l)
       (t (cons (funcall f (car l))
		(macro-mapall f (cdr l))))))

(defun macro-replace (form)
 (let fun ← (get (car form) 'macro) 
  then
  x ← (get fun 'subr)
  do
  (cond (x (subrcall nil x form))
	(t (progv (cadr fun) (ncons  form)
		  (eval (cons 'progn (cddr fun)))))) )) 

;(defun α-macro-replace (form)
;  (funcall (get (car form) 'α-macro) form))

(defun trans-replace (form)
 (let fun ← (get (car form) 'trans) 
  then
  x ← (get fun 'subr)
  do
  (cond (x (subrcall nil x form))
	(t (progv (cadr fun) (ncons  form)
		  (eval (cons 'progn (cddr fun)))))) )) 

(defun chartran fexpr (file)
 (apply 'eread file)
 (uwrite)
 (unselect-tty
  (select-disk-input
   (select-disk-output
    (tyi-until-eof with char do
	(cond ((member char '(13. 10.)) (tyi)(terpri))
	      ((let tran ← (get (ascii char) 'transtring) do
               (cond (tran (princ tran)))))  
	      (t (tyo char)))))))
 (apply 'ufile (list (car file) 'exp))
 file)

(defun count-lines fexpr (file)
 (apply 'eread file)
 (let n ← 0 do
 (unselect-tty
  (select-disk-input
    (tyi-until-eof with char do
	(cond ((member char '(13. 10.)) (tyi)(setq n (1+ n))))))) 
 n))

(defun count-sexprs fexpr (file)
 (apply 'eread file)
 (let n ← 0 do
 (unselect-tty
  (select-disk-input
    (read-until-eof with char do
	(setq n (1+ n)))))   
 n))

(defun m-e fexpr (l)
 (for i ε l do
  (setplist i (macro-expand (plist i)))) t)